home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Grab Bag
/
Shareware Grab Bag.iso
/
001
/
pibt3sp1.arc
/
DOCOMPUS.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1985-08-27
|
33KB
|
1,027 lines
(*----------------------------------------------------------------------*)
(* Do_CompuServe_B_Transfer --- Do Compuserve B Protocol transfer *)
(*----------------------------------------------------------------------*)
OVERLAY FUNCTION Do_CompuServe_B_Transfer : BOOLEAN;
(*----------------------------------------------------------------------*)
(* *)
(* Routine: Do_CompuServe_B_Transfer *)
(* *)
(* Purpose: Executes CompuServe B protocol transfers *)
(* *)
(* Calling Sequence: *)
(* *)
(* OK := Do_CompuServe_B_Transfer : BOOLEAN; *)
(* *)
(* OK --- set TRUE if transfer went OK *)
(* *)
(* Calls: None *)
(* *)
(* Called by: Emulate_VT52 *)
(* Emulate_ANSI *)
(* *)
(* Remarks: *)
(* *)
(* This code is taken from some prepared by Jim Nutt. *)
(* *)
(*----------------------------------------------------------------------*)
CONST
Xmt_Size = 511;
Rcv_Size = 512;
Max_Errors = 10;
(* Sender Actions *)
S_Send_packet = 0;
S_Get_DLE = 1;
S_Get_num = 2;
S_Get_seq = 3;
S_Get_data = 4;
S_Get_CheckSum = 5;
S_Timed_Out = 6;
S_Send_NAK = 7;
(* Receiver Actions *)
R_Get_DLE = 0;
R_Get_b = 1;
R_Get_seq = 2;
R_Get_data = 3;
R_Get_CheckSum = 4;
R_Send_NAK = 5;
R_Send_ACK = 6;
(* Other Constants *)
xmt_col = 50;
rcv_col = 36;
xon = 17;
xoff = 19;
dle = 16;
etx = 03;
nak = 21;
ENQ = 05;
wack = 59;
Err_Mess_Line = 5 (* Line for status report *);
TYPE
BufferType = ARRAY[0..520] OF BYTE;
VAR
Timer : INTEGER;
R_Size : INTEGER (* size of receiver buffer *);
CheckSum : INTEGER;
Seq_Num : INTEGER;
Ch : INTEGER; (* current character *)
Xoff_Flag : BOOLEAN;
Timed_Out : BOOLEAN (* we timed out before receiving character *);
Masked : BOOLEAN; (* TRUE if ctrl character was 'Masked' *)
S_Buffer : BufferType;
R_Buffer : BufferType;
FileName : AnyStr (* PathName *);
i : INTEGER;
n : INTEGER;
Dummy : BOOLEAN;
Comp_Title : AnyStr;
Total_Blocks : INTEGER (* Blocks processed so far *);
Total_Packets : INTEGER (* Packets thus far *);
Total_Errors : INTEGER (* Errors thus far *);
Halt_Transfer : BOOLEAN (* Keypressed to halt transfer *);
(*----------------------------------------------------------------------*)
PROCEDURE Update_B_Display;
BEGIN (* Update_B_Display *)
GoToXY( 22 , 1 );
WRITE( Total_Blocks );
ClrEol;
GoToXY( 22 , 2 );
WRITE( Total_Packets );
ClrEol;
GoToXY( 22 , 3 );
WRITE( Total_Errors );
ClrEol;
END (* Update_B_Display *);
(*----------------------------------------------------------------------*)
PROCEDURE Check_Keyboard;
VAR
Ch: CHAR;
BEGIN (* Check_Keyboard *)
IF KeyPressed THEN
BEGIN
READ( Kbd, Ch );
Halt_Transfer := Halt_Transfer OR ( Ch = CHR( ESC ) );
IF ( ( Ch = CHR( ESC ) ) AND KeyPressed ) THEN
READ( Kbd, Ch );
END;
END (* Check_Keyboard *);
(*----------------------------------------------------------------------*)
PROCEDURE Send_Masked_Byte( Ch : INTEGER );
BEGIN (* Send_Masked_Byte *)
IF ( Ch < 32 ) THEN
BEGIN
Async_Send( CHR( DLE ) );
Async_Send( CHR( Ch + ORD('@') ) );
END
ELSE
Async_Send( CHR( Ch ) );
END (* Send_Masked_Byte *);
(*----------------------------------------------------------------------*)
PROCEDURE Send_ACK;
BEGIN (* Send_ACK *)
Async_Send( CHR( DLE ) );
Async_Send( CHR( Seq_Num + ORD('0') ) );
Update_B_Display;
END (* Send_ACK *);
(*----------------------------------------------------------------------*)
PROCEDURE Send_NAK;
BEGIN (* Send_NAK *)
GoToXY( 22 , Err_Mess_Line );
WRITE('Sending NAK for block ', Total_Blocks );
ClrEol;
Async_Send( CHR( NAK ) );
Update_B_Display;
END (* Send_NAK *);
(*----------------------------------------------------------------------*)
PROCEDURE Send_ENQ;
BEGIN (* Send_ENQ *)
Async_Send( CHR( ENQ ) );
END (* Send_ENQ *);
(*----------------------------------------------------------------------*)
FUNCTION Read_Byte : BOOLEAN;
BEGIN (* Read_Byte *)
Timed_Out := FALSE;
Async_Receive_With_Timeout( Timer , Ch );
IF ( Ch = TimeOut ) THEN
BEGIN
Read_Byte := FALSE;
EXIT;
END;
Read_Byte := TRUE;
END (* Read_Byte *);
(*----------------------------------------------------------------------*)
FUNCTION Read_Masked_Byte : BOOLEAN;
BEGIN (* Read_Masked_Byte *)
Masked := FALSE;
IF NOT Read_Byte THEN
BEGIN
Read_Masked_Byte := FALSE;
EXIT;
END;
IF ( Ch = DLE ) THEN
BEGIN
IF NOT Read_Byte THEN
BEGIN
Read_Masked_Byte := FALSE;
EXIT;
END;
Ch := Ch AND $1F;
Masked := TRUE;
END;
Read_Masked_Byte := TRUE;
END (* Read_Masked_Byte *);
(*----------------------------------------------------------------------*)
PROCEDURE Do_CheckSum( Ch : INTEGER );
BEGIN (* Do_CheckSum *)
CheckSum := CheckSum SHL 1;
IF ( CheckSum > 255 ) THEN
CheckSum := ( CheckSum AND $FF ) + 1;
CheckSum := CheckSum + Ch;
IF ( CheckSum > 255 ) THEN
CheckSum := ( CheckSum AND $FF ) + 1;
END (* Do_CheckSum *);
(*----------------------------------------------------------------------*)
FUNCTION Send_Packet( size: INTEGER ) : BOOLEAN;
VAR
Action : INTEGER;
Errors : INTEGER;
Next_Seq : INTEGER;
Block_Num : INTEGER;
i : INTEGER;
Sent_ENQ : BOOLEAN;
Quit_Send : BOOLEAN;
BEGIN (* Send_Packet *)
Send_Packet := FALSE;
Quit_Send := FALSE;
Next_Seq := ( Seq_Num + 1 ) MOD 10;
Total_Packets := Total_Packets + 1;
Errors := 0;
Sent_ENQ := FALSE;
Action := S_Send_Packet;
WHILE ( NOT ( Quit_Send OR Halt_Transfer ) ) DO
BEGIN
Check_KeyBoard;
CASE Action OF
S_Send_Packet: BEGIN
CheckSum := 0;
Async_Send( CHR( DLE ) );
Async_Send( 'B' );
Async_Send( CHR( Next_Seq + ORD('0') ) );
Do_Checksum( Next_Seq + ORD('0') );
FOR i := 0 TO Size DO
BEGIN
Send_Masked_Byte( S_Buffer[i] );
Do_Checksum ( S_Buffer[i] );
END;
Async_Send( CHR( ETX ) );
Do_Checksum( ETX );
Send_Masked_Byte( CheckSum );
Action := S_Get_DLE;
END;
S_Get_DLE: BEGIN
Timer := 30;
IF NOT Read_Byte THEN
Action := S_Timed_Out
ELSE IF ( Ch = DLE ) THEN
Action := S_Get_num
ELSE IF ( Ch = NAK ) THEN
BEGIN
Errors := Errors + 1;
Total_Errors := Total_Errors + 1;
IF ( Errors > Max_Errors ) THEN
BEGIN
Send_Packet := FALSE;
Quit_Send := TRUE;
END
ELSE
Action := S_Send_Packet;
END
ELSE IF ( Ch = ETX ) THEN
Action := S_Send_NAK;
END;
S_Get_num: BEGIN
Timer := 30;
IF NOT Read_Byte THEN
Action := S_Timed_Out
ELSE IF ( Ch >= ORD('0') ) AND ( Ch <= ORD('9') ) THEN
BEGIN
IF ( ( Ch - ORD('0') ) = Seq_Num ) THEN
IF Sent_ENQ THEN
Action := S_Send_Packet
ELSE Action := S_Get_DLE
ELSE
IF ( ( Ch - ORD('0') ) = Next_Seq ) THEN
BEGIN
Seq_Num := Next_Seq;
Send_Packet := TRUE;
Quit_Send := TRUE;
END
ELSE
IF ( Errors = 0 ) THEN
Action := S_Send_Packet
ELSE
Action := S_Get_DLE;
END
ELSE IF ( Ch = nak ) THEN
Action := S_Send_Packet
ELSE IF ( Ch = wack ) THEN
BEGIN
Timer := Timer + 10;
Action := S_Get_DLE;
END
ELSE IF ( Ch = ORD('B') ) THEN
Action := S_Get_seq
ELSE IF ( Ch = etx ) THEN
Action := S_Send_NAK
ELSE
Action := S_Get_DLE;
END;
S_Get_seq: BEGIN
Timer := 10;
IF NOT Read_Byte THEN
Action := S_Send_NAK
ELSE
BEGIN
CheckSum := 0;
Block_Num := Ch - ORD('0');
Do_Checksum( Ch );
i := 0;
Action := S_Get_data;
END;
END;
S_Get_data: BEGIN
Timer := 10;
IF NOT Read_Masked_Byte THEN
Action := S_Send_NAK
ELSE IF ( ( Ch = etx ) AND ( NOT Masked ) ) THEN
BEGIN
Do_Checksum( ETX );
Action := S_Get_CheckSum;
END
ELSE
BEGIN
R_Buffer[i] := Ch;
i := i + 1;
Do_Checksum( Ch );
END;
END;
S_Get_CheckSum: BEGIN
Timer := 10;
IF ( NOT Read_Masked_Byte ) THEN
Action := S_Send_NAK
ELSE IF ( Ch <> CheckSum ) THEN
Action := S_Send_NAK
ELSE IF ( Block_Num <>
( ( Next_Seq + 1 ) mod 10 ) ) THEN
Action := S_Send_NAK
ELSE
BEGIN
Seq_Num := Block_Num;
Send_ACK;
R_Size := i;
Send_Packet := TRUE;
Quit_Send := TRUE;
END;
END;
S_Timed_Out: BEGIN
Errors := Errors + 1;
Total_Errors := Total_Errors + 1;
IF ( Errors > 4 ) THEN
BEGIN
Send_Packet := FALSE;
Quit_Send := TRUE;
END;
Action := S_Get_DLE;
END;
S_Send_NAK: BEGIN
Errors := Errors + 1;
Total_Errors := Total_Errors + 1;
IF ( Errors > Max_Errors ) THEN
BEGIN
Send_Packet := FALSE;
Quit_Send := TRUE;
END;
Send_NAK;
Action := S_Get_DLE;
END;
END (* CASE *);
Update_B_Display;
END (* BEGIN *);
END (* Send_Packet *);
(*----------------------------------------------------------------------*)
PROCEDURE Send_Failure( Code : CHAR );
VAR
Dummy : BOOLEAN;
BEGIN (* Send_Failure *)
S_Buffer[0] := ORD( 'F' );
S_Buffer[1] := ORD( Code );
Dummy := Send_Packet( 2 );
END (* Send_Failure *);
(*----------------------------------------------------------------------*)
FUNCTION Read_File( VAR Data_File : INTEGER;
VAR S_Buffer : BufferType;
n : INTEGER;
Xmt_Size : INTEGER ) : INTEGER;
VAR
I : INTEGER;
L : INTEGER;
BEGIN (* Read_File *)
L := Xmt_Size;
I := Read_File_Handle( Data_File, S_Buffer[n], L );
Read_File := L;
END (* Read_File *);
(*----------------------------------------------------------------------*)
FUNCTION Send_File( Name : AnyStr ) : BOOLEAN;
VAR
n : INTEGER;
Data_File : INTEGER;
IO_Error : INTEGER;
BEGIN (* Send_File *)
(* Assume send fails *)
Send_File := FALSE;
(* Open file to be uploaded *)
IO_Error := Open_File_Handle( Name , Access_Read_Mode , Data_File );
(* If file can't be opened, halt *)
(* transfer. *)
IF ( IO_Error <> 0 ) THEN
BEGIN
Send_Failure('E');
GoToXY( 22 , Err_Mess_Line );
WRITE('Can''t open file to be sent, transfer stopped.');
ClrEol;
EXIT;
END;
REPEAT
(* Read next sector of data *)
S_Buffer[0] := ORD('N');
n := Read_File( Data_File, S_Buffer, 1, Xmt_Size );
(* Send data packet if anything *)
(* to send. *)
IF ( n > 0 ) THEN
BEGIN
(* If packet not sent, report *)
(* failure. *)
Total_Blocks := Total_Blocks + 1;
IF ( NOT Send_Packet( n ) ) THEN
BEGIN
GoToXY( 22 , Err_Mess_Line );
WRITE('Can''t send packet, transfer stopped.');
ClrEol;
Halt_Transfer := TRUE;
END;
END;
(* Check for keyboard input halting *)
(* transfer. *)
Check_Keyboard;
IF Halt_Transfer THEN
BEGIN
Send_Failure('E');
GoToXY( 22 , Err_Mess_Line );
WRITE('ESC key hit -- transfer terminated.');
ClrEol;
END;
Update_B_Display;
UNTIL ( n <= 0 ) OR Halt_Transfer;
(* Close file *)
IO_Error := Close_File_Handle( Data_File );
IF ( NOT Halt_Transfer ) THEN
BEGIN
(* Send end of file packet. *)
S_Buffer[0] := ORD('T');
S_Buffer[1] := ORD('C');
IF ( NOT Send_Packet( 2 ) ) THEN
BEGIN
GoToXY( 22 , Err_Mess_Line );
WRITE('Can''t send end of file packet, transfer stopped.');
ClrEol;
END
ELSE
Send_File := TRUE;
END;
END (* Send_File *);
(*----------------------------------------------------------------------*)
FUNCTION Read_Packet : BOOLEAN;
(* True if packet is available from host *)
VAR
Action : INTEGER;
Next_Seq : INTEGER;
Block_Num : INTEGER;
Errors : INTEGER;
i : INTEGER;
BEGIN (* Read_Packet *)
(* Clear out packet area *)
FillChar( R_Buffer , 520 , 0 );
(* Packet sequence number *)
Next_Seq := ( Seq_Num + 1 ) MOD 10;
Errors := 0;
Action := R_Get_DLE;
Total_Packets := Total_Packets + 1;
(* Get next packet *)
WHILE ( NOT Halt_Transfer ) DO
BEGIN
Check_KeyBoard;
Timer := 10;
CASE Action OF
R_Get_DLE: BEGIN
IF ( NOT Read_Byte ) THEN
Action := R_Send_NAK
ELSE IF ( ( Ch AND $7F ) = dle ) THEN
Action := R_Get_b
ELSE IF ( ( Ch AND $7F ) = ENQ ) THEN
Action := R_Send_ACK;
END;
R_Get_b: BEGIN
IF ( NOT Read_Byte ) THEN
Action := R_Send_NAK
ELSE IF ( ( Ch AND $7F ) = ORD('B') ) THEN
Action := R_Get_seq
ELSE IF ( Ch = ENQ ) THEN
Action := R_Send_ACK
ELSE
Action := R_Get_DLE;
END;
R_Get_seq: BEGIN
IF ( NOT Read_Byte ) THEN
Action := R_Send_NAK
ELSE IF ( Ch = ENQ ) THEN
Action := R_Send_ACK
ELSE
BEGIN
CheckSum := 0;
Block_Num := Ch - ORD('0');
Do_Checksum( Ch );
i := 0;
Action := R_Get_data;
END;
END;
R_Get_data: BEGIN
IF ( NOT Read_Masked_Byte ) THEN
Action := R_Send_NAK
ELSE IF ( ( Ch = etx ) AND ( NOT Masked ) ) THEN
BEGIN
Do_Checksum( etx );
Action := R_Get_CheckSum;
END
ELSE
BEGIN
R_Buffer[i] := Ch;
i := i + 1;
Do_Checksum( Ch );
END;
END;
R_Get_CheckSum: BEGIN
IF ( NOT Read_Masked_Byte ) THEN
Action := R_Send_NAK
ELSE IF ( Ch <> CheckSum ) THEN
Action := R_Send_NAK
ELSE IF ( Block_Num = Seq_Num ) THEN
BEGIN
IF ( R_Buffer[0] = ORD('F') ) THEN
BEGIN
Seq_Num := Block_Num;
R_Size := i;
Read_Packet := TRUE;
EXIT;
END
ELSE
Action := R_Send_ACK;
END
ELSE IF ( Block_Num <> Next_Seq ) THEN
Action := R_Send_NAK
ELSE
BEGIN
Seq_Num := Block_Num;
R_Size := i;
Read_Packet := TRUE;
EXIT;
END;
END;
R_Send_NAK: BEGIN
Errors := Errors + 1;
Total_Errors := Total_Errors + 1;
IF ( Errors > Max_Errors ) THEN
BEGIN
Read_Packet := FALSE;
EXIT;
end;
Send_NAK;
Action := R_Get_DLE;
END;
R_Send_ACK: BEGIN
(* wait for the next block *)
Send_ACK;
Action := R_Get_DLE;
END;
END (* CASE *);
END (* WHILE *);
END (* Read_Packet *);
(*----------------------------------------------------------------------*)
FUNCTION Write_File( VAR Data_File : INTEGER;
R_Buffer : BufferType;
n : INTEGER;
size : INTEGER) : INTEGER;
BEGIN (* Write_File *)
Write_File := Write_File_Handle( Data_File, R_Buffer[ n ], size );
END (* Write_File *);
(*----------------------------------------------------------------------*)
FUNCTION Receive_File( Name : AnyStr ) : BOOLEAN;
VAR
Data_File : INTEGER;
Status : INTEGER;
R_File : BOOLEAN;
BEGIN (* Receive_File *)
(* Assume transfer fails *)
R_File := FALSE;
(* Open file to be created *)
Status := Create_File_Handle( Name, Attribute_None, Data_File );
(* Halt transfer if file can't be *)
(* opened. *)
IF ( Status <> 0 ) THEN
BEGIN
Send_Failure('E');
GoToXY( 22 , Err_Mess_Line );
WRITE('Can''t open output file, transfer stoppped.');
ClrEol;
Receive_File := FALSE;
EXIT;
END;
(* Send ACK to start transfer *)
Send_ACK;
(* Begin loop over packets *)
WHILE ( NOT ( Halt_Transfer OR R_File ) ) DO
BEGIN
(* Get next packet *)
IF Read_Packet THEN
BEGIN
(* Select Action based upon packet type *)
CASE CHR( R_Buffer[0] ) OF
(* Data for file -- write it and *)
(* acknowledge it. *)
'N': BEGIN
Status := Write_File( Data_File, R_Buffer, 1,
R_Size - 1 );
Send_ACK;
Total_Blocks := Total_Blocks + 1;
END;
(* End of transfer -- close file *)
(* and acknowledge end of file *)
'T': BEGIN
IF ( R_Buffer[1] = ORD('C') ) THEN
BEGIN
GoToXY( 22 , Err_Mess_Line );
WRITE('Transfer Complete');
ClrEol;
Status := Close_File_Handle( Data_File );
Send_ACK;
R_File := TRUE;
DELAY( Two_Second_Delay );
END;
END;
(* Stop transfer received -- halt *)
(* transfer and acknowledge. *)
'F': BEGIN
Send_ACK;
Halt_Transfer := TRUE;
GoToXY( 22 , Err_Mess_Line );
WRITE('Host cancelled transfer.');
ClrEol;
DELAY( Two_Second_Delay );
END;
END (* CASE *);
END (* IF *);
(* Check for keyboard input halting *)
(* transfer. *)
Check_Keyboard;
IF Halt_Transfer THEN
BEGIN
Send_Failure('E');
GoToXY( 22 , Err_Mess_Line );
WRITE('ESC key hit -- transfer terminated.');
ClrEol;
END;
END (* WHILE *);
Receive_File := R_File;
Status := Close_File_Handle( Data_File );
END (* Receive_File *);
(*--------------- CompuServe_B_Transfer --- main code -------------------*)
BEGIN (* Do_CompuServe_B_Transfer *)
(* Reset comm parms to 8,n,1 *)
Xmodem_Bits_Save := Data_Bits;
Xmodem_Parity_Save := Parity;
Xmodem_Stop_Save := Stop_Bits;
Async_Reset_Port( Comm_Port, Baud_Rate, 'N', 8, 1 );
(* Announce protocol starts *)
Save_Screen( Saved_Screen );
Draw_Menu_Frame( 5, 10, 75, 16, Menu_Frame_Color,
Menu_Text_Color, 'CompuServe B Protocol' );
GoToXY( 1 , 1 );
WRITE('Blocks transferred: ');
GoToXY( 1 , 2 );
WRITE('Packets transferred: ');
GoToXY( 1 , 3 );
WRITE('Total errors: ');
GoTOXY( 1 , Err_Mess_Line );
WRITE('Last status message: ');
(* Assume transfer goes OK *)
Do_CompuServe_B_Transfer := TRUE;
Halt_Transfer := FALSE;
Xoff_Flag := FALSE;
Seq_Num := 0;
Comp_Title := 'CIS B -- ';
Total_Blocks := 0;
Total_Packets := 0;
Total_Errors := 0;
(* ACKnowledge start of protocol *)
Send_ACK;
(* Read initial packet *)
IF Read_Packet THEN
BEGIN
(* Select Action based upon packet type *)
CASE CHR( R_Buffer[0] ) OF
(* Upload or download *)
'T': BEGIN
CASE CHR( R_Buffer[1] ) OF
'D' : Comp_Title := 'Receiving ';
'U' : Comp_Title := 'Sending ';
ELSE
BEGIN
Send_Failure('N');
Do_CompuServe_B_Transfer := FALSE;
EXIT;
END;
END (* CASE *);
(* Get file name *)
CASE CHR( R_Buffer[2] ) OF
'A': Comp_Title := Comp_Title + 'ASCII file "';
'B': Comp_Title := Comp_Title + 'Binary file "';
ELSE
BEGIN
Send_Failure('N'); (* Not implemented *)
Do_CompuServe_B_Transfer := FALSE;
EXIT;
END;
END (* CASE *);
i := 2;
FileName := '';
WHILE ( R_Buffer[i] <> 0 ) AND ( i < R_Size ) DO
BEGIN
i := i + 1;
FileName := FileName + CHR( R_Buffer[i] );
END;
Comp_Title := Comp_Title + FileName + '"';
(* Display file transfer header *)
Draw_Menu_Frame( 5, 10, 75, 16, Menu_Frame_Color,
Menu_Text_Color, Comp_Title );
GoToXY( 1 , 1 );
WRITE('Blocks transferred: ');
GoToXY( 1 , 2 );
WRITE('Packets transferred: ');
GoToXY( 1 , 3 );
WRITE('Total errors: ');
GoTOXY( 1 , Err_Mess_Line );
WRITE('Last status message: ');
(* Perform transfer *)
IF ( R_Buffer[1] = ORD('U') ) THEN
Dummy := Send_File( FileName )
ELSE
Dummy := Receive_File( FileName );
END;
END (* CASE *);
END (* IF *)
(* No initial packet -- quit *)
ELSE
BEGIN
GoToXY( 22 , Err_Mess_Line );
WRITE('Cannot receive initial packet, transfer aborted');
ClrEol;
DELAY( Two_Second_Delay );
END;
(* Restore previous screen *)
Restore_Screen( Saved_Screen );
Reset_Global_Colors;
(* Reset comm parms back *)
Async_Reset_Port( Comm_Port, Baud_Rate, Xmodem_Parity_Save,
Xmodem_Bits_Save, Xmodem_Stop_Save );
END (* Do_CompuServe_B_Transfer *);